--  ---------------------------------------------------------------------------
--  @File: document.adb
--
--  @Project: LiberAda
--  @Version: 1.0
--  @Created: 2009-10-13
--  @Author:  Ivan Bogicevic, Julian Trischler
--
--  @Description:
--    For a detailed description of this package (@see document.ads).
--  @Implementation:
--    By adding tokens and symbols of a source file to the document, the
--    corresponding html parts are generated and stored. All this data and
--    the general skeleton of a html file can then be written out to the
--    destination html file.
--
--  @Modifications:
--    +2009-10-13 IB: Initial release
--    +2011-07-14 JT: Added table of contents support
--  ---------------------------------------------------------------------------
with Ada.Text_IO;

with Settings;
with File_Tools;

package body Document is

   STYLESHEET : constant String :=
      "code { white-space: pre; } " &
      "code .keyword { color:blue; font-weight:bold } " &
      "code .string { color:green } " &
      "code .comment { color:gray; font-style:italic } " &
      ".box { background-color: snow; border: solid 1px #FFCC99; " &
      "padding: 1em; margin: 5px; } " &
      "h2 { font-size: 1.2em; } " &
      "h1, h2, h3 { margin-top: 0; padding-top: 0 } ";

   --  ----------------------------------------------------------------------
   --  @Procedure: Set_In_File
   procedure Set_In_File
     (This    : in out Document_Type;
      In_File : in     ASU.Unbounded_String) is

      File_Name : constant String := File_Tools.Extract_Filename
        (ASU.To_String (In_File), True, ".");
   begin
      This.In_File := In_File;
      Part.Set_Value (This.Title, "liberAda - " & File_Name);
      Part.Set_Value (This.Head, File_Name);
   end Set_In_File;

   --  ----------------------------------------------------------------------
   --  @Function: Get_In_File
   function Get_In_File
     (This : in Document_Type) return ASU.Unbounded_String is
   begin
      return This.In_File;
   end Get_In_File;

   --  ----------------------------------------------------------------------
   --  @Function: Get_Out_File
   function Get_Out_File
     (This : in Document_Type) return ASU.Unbounded_String is
   begin
      return ASU.To_Unbounded_String (Settings.Output_Directory & "/"
        & File_Tools.Extract_Filename (ASU.To_String (This.In_File), True)
        & ".html");
   end Get_Out_File;

   --  ----------------------------------------------------------------------
   --  @Procedure: Add_Token
   procedure Add_Token
     (This   : in out Document_Type;
      Kind   : in     Ada_Tokenizer.Token_Type;
      Value  : in     ASU.Unbounded_String) is
      use Ada_Tokenizer;

      Code_Part : Part.Part_Type := Part.Create;
   begin
      Part.Set_Value (Code_Part, ASU.To_String (Value));
      --  The html formatting varies depending on the kind of the token
      case Kind is
         --  Reserved words (see type Ada_Token in ada_lexer.ads for details)
         when ABORT_T .. XOR_T =>
            Part.Add_Attribute_Before (Code_Part,
              "<span class='keyword'>");
            Part.Add_Attribute_After (Code_Part, "</span>");
         --  Literals
         when INTEGER_T .. STRING_T =>
            Part.Add_Attribute_Before (Code_Part,
              "<span class='string'>");
            Part.Add_Attribute_After (Code_Part, "</span>");
         --  Comments
         when COMMENT_T =>
            Part.Add_Attribute_Before (Code_Part,
              "<span class='comment'>");
            Part.Add_Attribute_After (Code_Part, "</span>");
         --  All other (e.g. whitespaces)
         when others =>
            null;
      end case;
      Part.Add_Part (This.Code, Code_Part);
   end Add_Token;

   --  ----------------------------------------------------------------------
   --  @Procedure: Add_Comment
   procedure Add_Comment
     (This    : in out Document_Type;
      Comment : in     Comment_Parser.Comment_Type) is
   begin
      --  TODO: The header of a file should be written to an overview
      --        section.
      case Comment.Get_Paragraph_Type is
         when Comment_Parser.TYPE_T =>
            Comment.Add_To_Document (This.Types);
         when Comment_Parser.CONSTANT_T =>
            Comment.Add_To_Document (This.Constants);
         when Comment_Parser.FUNCTION_T | Comment_Parser.PROCEDURE_T =>
            Comment.Add_To_Document (This.Routines);
         when Comment_Parser.EXCEPTION_T =>
            Comment.Add_To_Document (This.Exceptions);
         when Comment_Parser.GLOBAL_VARIABLE_T =>
            Comment.Add_To_Document (This.Variables);
         when others =>
            null;
      end case;
   end Add_Comment;

   --  ----------------------------------------------------------------------
   --  @Function: Translate_Special_Chars
   function Translate_Special_Chars
     (In_Str : in String) return String is
      Out_Str : ASU.Unbounded_String;
   begin
      for Idx in In_Str'Range loop
         case In_Str (Idx) is
            when '>' =>
               ASU.Append (Out_Str, "&gt;");
            when '<' =>
               ASU.Append (Out_Str, "&lt;");
            when '&' =>
               ASU.Append (Out_Str, "&amp;");
            when others =>
               ASU.Append (Out_Str, In_Str (Idx));
         end case;
      end loop;
      return ASU.To_String (Out_Str);
   end Translate_Special_Chars;

   --  ----------------------------------------------------------------------
   --  @Procedure: Make_Table_Of_Contents
   --  @Description: Creates the linked table of contents and puts it into
   --    the TOC document part, so when outputting the document the users
   --    have easy access to types, procedures and so on.
   --
   --    This routine will link types, constants, exceptions, variables and
   --    routines as well as source code. Empty parts are skipped. When
   --    calling this procedure the table of contents is always newly
   --    generated and appended to the existing one. Make sure you call it
   --    after all parts are generated in the document.
   --
   --    TODO: clear TOC before appending stuff so this is idempotent
   --  @Parameter:
   --    +This: the document which's TOC should be generated
   procedure Make_Table_Of_Contents (This : in out Document_Type) is

      --  -------------------------------------------------------------------
      --  @Procedure: Make_TOC
      --  @Description: Generate table of contents entry of P if P is not
      --    empty and has an anchor to link to.
      --  @Parameter:
      --    +TOC_Parent: the parent part where to insert the TOC for the
      --      given part P if P should be included
      --    +P: the part to include in the TOC if it's not empty and has
      --      and anchor
      procedure Make_TOC (TOC_Parent, P : in out Part.Part_Type) is
         TOC_Part : Part.Part_Type := Part.Create;
         TOC_Link : Part.Part_Type := Part.Create;
      begin
         if Part.Has_Parts (P) and then Part.Has_Anchor (P) then
            Part.Add_Attribute_Before (TOC_Part, "<li>");
            Part.Add_Attribute_Before (TOC_Link, "<a href='#" &
              Translate_Special_Chars (Part.Anchor (P)) & "'>");
            Part.Set_Value (TOC_Link, Part.Title (P));
            Part.Add_Attribute_After (TOC_Link, "</a>");
            Part.Add_Attribute_After (TOC_Part, "</li>");
            Part.Add_Part (TOC_Part, TOC_Link);
            Part.Add_Part (TOC_Parent, TOC_Part);
            if Part.Has_Parts (P) then
               declare
                  Parts : constant Part.Parts_Type := Part.Parts (P);
                  Sub_Tree : Part.Part_Type := Part.Create;
                  Tmp_P : Part.Part_Type;
               begin
                  for I in Parts'Range loop
                     Tmp_P := Parts (I);
                     Make_TOC (Sub_Tree, Tmp_P);
                  end loop;

                  --  check for <ul> ... </ul> insertion
                  if Part.Parts (Sub_Tree)'Length > 0 then
                     Part.Add_Attribute_Before (Sub_Tree, "<ul>");
                     Part.Add_Part (TOC_Part, Sub_Tree);
                     Part.Add_Attribute_After (Sub_Tree, "</ul>");
                  end if;
               end;
            end if;
         end if;
      end Make_TOC;
   begin
      Make_TOC (This.TOC, This.Types);
      Make_TOC (This.TOC, This.Constants);
      Make_TOC (This.TOC, This.Exceptions);
      Make_TOC (This.TOC, This.Variables);
      Make_TOC (This.TOC, This.Routines);
      Make_TOC (This.TOC, This.Code);
   end Make_Table_Of_Contents;

   --  ----------------------------------------------------------------------
   --  @Procedure: Write_HTML
   procedure Write_HTML (This : in Document_Type) is
      use Ada.Text_IO;

      File : File_Type;

      --  -------------------------------------------------------------------
      --  @Procedure: Write_Part
      --  @Description:
      --    Writes the current part and recursively all sub-parts to
      --    the given file.
      --  @Parameter:
      --    +File: to write to
      --    +Curr_Part: part to write to file including its sub-parts
      procedure Write_Part
        (File : in File_Type;
         Curr_Part : in Part.Part_Type) is

         use type Part.Part_Type;
      begin
         --  Skip all empty sub-sections
         if Curr_Part = This.Types or else
           Curr_Part = This.Constants or else
           Curr_Part = This.Exceptions or else
           Curr_Part = This.Variables or else
           Curr_Part = This.Routines then
            if not Part.Has_Parts (Curr_Part) then
               return;
            end if;
         end if;

         --  Write opening box and anchor or title if necessary
         --  (titles are linked blocks are handled here)
         if Part.Has_Anchor (Curr_Part) then
            Put (File, "<div class='box' id='" & Translate_Special_Chars (
              Part.Anchor (Curr_Part)) & "'>");
            if Part.Has_Title (Curr_Part) then
               declare
                  Level : constant String :=
                    Part.Level (Curr_Part)'Img (2 .. 2);
               begin
                  Put (File, "<h" & Level & "><a href='#" &
                    Translate_Special_Chars (Part.Anchor (Curr_Part)) &
                    "'>" & Part.Title (Curr_Part) & "</a></h" & Level & ">");
               end;
            else
               Put (File, "<a name='" & Translate_Special_Chars (
                 Part.Anchor (Curr_Part)) & "'></a>");
            end if;
         end if;

         --  Write all attributes before this part's content
         if Part.Has_Attributes_Before (Curr_Part) then
            declare
               Attrs : constant Part.Attributes_Type :=
                 Part.Attributes_Before (Curr_Part);
            begin
               for Attr_Idx in Attrs'Range loop
                  Put (File, ASU.To_String (Attrs (Attr_Idx)));
               end loop;
            end;
         end if;

         --  Write the content of this part
         Put (File, Translate_Special_Chars (Part.Value (Curr_Part)));

         --  Write the sub-parts of this parts
         if Part.Has_Parts (Curr_Part) then
            declare
               Parts : constant Part.Parts_Type := Part.Parts (Curr_Part);
            begin
               for Parts_Idx in Parts'Range loop
                  Write_Part (File, Parts (Parts_Idx));
               end loop;
            end;
         end if;

         --  Write the attributes after this part's content
         if Part.Has_Attributes_After (Curr_Part) then
            declare
               Attrs : constant Part.Attributes_Type :=
                 Part.Attributes_After (Curr_Part);
            begin
               for Attr_Idx in Attrs'Range loop
                  Put (File, ASU.To_String (Attrs (Attr_Idx)));
               end loop;
            end;
         end if;

         --  Write closing box, if necessary
         if Part.Has_Anchor (Curr_Part) then
            Put (File, "</div>");
         end if;
      end Write_Part;

   --  ----------------------------------------------------------------------
   begin
      pragma Assert (Part.Exists (This.Root));

      Create (File, Name => Ada.Strings.Unbounded.To_String (
        This.Get_Out_File));
      Write_Part (File, This.Root);
      Close (File);

      if Settings.Verbose then
         New_Line;
         Put_Line ("-> HTML-File written to " &
           Ada.Strings.Unbounded.To_String (This.Get_Out_File));
      end if;
   end Write_HTML;

   --  ----------------------------------------------------------------------
   --  @Function: "="
   function "=" (Left, Right : Document_Type) return Boolean is
      use Ada.Strings.Unbounded;
   begin
      return Left.In_File = Right.In_File;
   end "=";

   --  ----------------------------------------------------------------------
   --  @Procedure: Initialize
   procedure Initialize (This : out Document_Type) is
   begin
      This.Root := Part.Create;
      Part.Add_Attribute_Before (This.Root,
        "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.01 Transitional" &
        "//EN"" ""http://www.w3.org/TR/html4/loose.dtd"">");

      Part.Add_Attribute_Before (This.Root, "<html>");
      Part.Add_Attribute_After (This.Root, "</html>");

      This.Title := Part.Create;
      Part.Add_Attribute_Before (This.Title, "<head>");
      Part.Add_Attribute_Before (This.Title, "<title>");
      Part.Set_Value (This.Title, "liberAda");
      Part.Add_Attribute_After (This.Title, "</title>");
      Part.Add_Attribute_After (This.Title,
        "<style type='text/css'>" & STYLESHEET & "</style>");
      Part.Add_Attribute_After (This.Title, "</head>");
      Part.Add_Part (This.Root, This.Title);

      This.Content := Part.Create;
      Part.Add_Attribute_Before (This.Content, "<body>");
      Part.Add_Attribute_After (This.Content, "</body>");
      Part.Add_Part (This.Root, This.Content);

      This.Head := Part.Create_Part (Value => "liberAda", Tag => "h1");
      Part.Add_Part (This.Content, This.Head);

      This.TOC := Part.Create (Anchor => "toc", Title => "Table of Contents",
        Level => 2);
      Part.Add_Attribute_Before (This.TOC, "<ul>");
      Part.Add_Attribute_After (This.TOC, "</ul>");
      Part.Add_Part (This.Content, This.TOC);

      This.Types := Part.Create (Anchor => "types", Title => "Types",
        Level => 2);
      Part.Add_Part (This.Content, This.Types);

      This.Constants := Part.Create (Anchor => "constants",
        Title => "Constants", Level => 2);
      Part.Add_Part (This.Content, This.Constants);

      This.Exceptions := Part.Create (Anchor => "exceptions",
        Title => "Exceptions", Level => 2);
      Part.Add_Part (This.Content, This.Exceptions);

      This.Variables := Part.Create (Anchor => "variables",
        Title => "Variables", Level => 2);
      Part.Add_Part (This.Content, This.Variables);

      This.Routines := Part.Create (Anchor => "routines",
        Title => "Functions and Procedures", Level => 2);
      Part.Add_Part (This.Content, This.Routines);

      This.Code := Part.Create (Anchor => "code", Title => "Source Code",
        Level => 2);
      Part.Add_Part (This.Content, This.Code);
      Part.Add_Attribute_Before (This.Code, "<code>");
      Part.Add_Attribute_After (This.Code, "</code>");
   end Initialize;

   --  ----------------------------------------------------------------------
   --  @Procedure: Destroy
   procedure Destroy (This : in out Document_Type) is

      --  -------------------------------------------------------------------
      --  @Procedure: Destroy_Part
      --  @Description:
      --    Destroys the current part and recursively all its sub-parts.
      procedure Destroy_Part (Curr_Part : in out Part.Part_Type) is
      begin
         if Part.Has_Parts (Curr_Part) then
            declare
               Parts : Part.Parts_Type := Part.Parts (Curr_Part);
            begin
               for Parts_Idx in Parts'Range loop
                  Destroy_Part (Parts (Parts_Idx));
               end loop;
            end;
         end if;
         Part.Destroy (Curr_Part);
      end Destroy_Part;
   begin
      if Part.Exists (This.Root) then
         Destroy_Part (This.Root);
      end if;
   end Destroy;

end Document;
